perm filename CYCOMD[1,LMM] blob
sn#034827 filedate 1973-04-12 generic text, type T, neo UTF8
(COMMENT GROUP AND LABELLING FUNCTIONS)
(DE CHECKL (S SB NPL)
(IF (SETQ NPL (CHECK S SB NPL 0))
THEN
(IF (REMPERMS (NPLLEFT NPL))
THEN
(PRINT (LIST (QUOTE CHECKL)
(QUOTE ERROR:)
S SB NPL))
NIL ELSE
(LIST (LABELING LABELED = S UNLABELED = SB LSTRUC =
(REVERSE (OKPERMS (NPLLEFT NPL))))))
ELSE NIL))
)))))))))))))))))
(DE COMB (OBJ S SB NPL LABELS)
(IF (ZEROP LABELS)
THEN
(CHECKL S (APPEND SB OBJ)
NPL)
ELSEIF
(EQUAL LABELS (LENGTH OBJ))
THEN
(CHECKL (APPEND OBJ S)
SB NPL)
ELSEIF
(GREATERP LABELS (LENGTH OBJ))
THEN NIL ELSE (APPEND (COMBCHECK (CDR OBJ)
(CONS (CAR OBJ)
S)
SB NPL (SUB1 LABELS))
(COMBCHECK (CDR OBJ)
S
(CONS (CAR OBJ)
SB)
NPL LABELS))))
)))))))))))))))))
(DE COMBCHECK (OBJ S SB NPL LABELS)
(IF (SETQ NPL (CHECK S SB NPL LABELS))
THEN
(COMB (DIFF OBJ (LABELEDSOFAR NPL))
(LABELEDSOFAR NPL)
SB
(NPLLEFT NPL)
(LABELSLEFT NPL))
ELSE NIL))
)))))))))))))))))
(DE CHECK (S SB NPL LABELS)
(PROG (NEWNPL OBJ POBJ OK)
(SETQ OK (OKPERMS NPL))
(SETQ NPL (REMPERMS NPL))
L1
(IF (NULL NPL)
THEN
(RETURN (CHECKVAL LABELEDSOFAR = S NPLLEFT =
(NPL OKPERMS = OK REMPERMS = NEWNPL)
LABELSLEFT = LABELS)))
(SETQ OBJ (OBJ (CAR NPL)))
(SETQ POBJ (POBJ (CAR NPL)))
L3
(IF (NULL OBJ)
THEN
(GO L8)
ELSEIF
(MEMBER (CAR OBJ)
S)
THEN
(GO L4)
ELSEIF
(MEMBER (CAR OBJ)
SB)
THEN
(GO L5))
L6
(SETQ NEWNPL (CONS (CHECKPERM FROM (CAR NPL)
OBJ = OBJ POBJ = POBJ)
NEWNPL))
L2
(SETQ NPL (CDR NPL))
(GO L1)
L9
(SETQ NEWNPL NIL)
L8
(SETQ OK (CONS (ORIGPERM (CAR NPL))
OK))
(GO L2)
L4
(IF (MEMBER (CAR POBJ)
S)
THEN
(GO L7)
ELSEIF
(MEMBER (CAR POBJ)
SB)
THEN
(RETURN NIL)
ELSEIF
(MINUSP (SETQ LABELS (SUB1 LABELS)))
THEN
(RETURN NIL))
(SETQ S (CONS (CAR POBJ)
S))
(SETQ NPL (APPEND NEWNPL NPL))
(IF (NULL (CDR OBJ))
THEN
(GO L9))
(SETQ NEWNPL (LIST (CHECKPERM FROM (CAR NPL)
OBJ = (CDR OBJ)
POBJ = (CDR POBJ))))
(GO L2)
L7
(SETQ OBJ (CDR OBJ))
(SETQ POBJ (CDR POBJ))
(GO L3)
L5
(IF (MEMBER (CAR POBJ)
S)
THEN
(GO L2)
ELSEIF
(MEMBER (CAR POBJ)
SB)
THEN
(GO L7))
(GO L6)))
)))))))))))))))))
(DE LLABEL (OBJECTS LABELS STRUC)
(IF (NULL LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC))
ELSE
(FOR NEW L1 IN (LABELM (CAR OBJECTS)
(CAR LABELS)
STRUC)
FOR NEW L2 IN (LLABEL (CDR OBJECTS)
(CDR LABELS)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED = (CONS (LABELED L1)
**)))))
)))))))))))))))))
(DE LABELM (OBJECTS LABELS STRUC)
(IF (NULL LABELS)
THEN
(LIST (LABELING UNLABELED = OBJECTS LSTRUC = STRUC))
ELSE
(FOR NEW L1 IN (LABEL1 OBJECTS (CAR LABELS)
STRUC)
FOR NEW L2 IN (LABELM (UNLABELED L1)
(CDR LABELS)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED = (CONS (LABELED L1)
**)))))
)))))))))))))))))
(DE LABEL1 (OBJECTS LABELS STRUC)
(PROG (SZ)
(RETURN (IF (ZEROP LABELS)
THEN
(LIST (LABELING UNLABELED = OBJECTS LSTRUC =
STRUC))
ELSEIF
(EQUAL LABELS (SETQ SZ (SIZE OBJECTS)))
THEN
(LIST (LABELING LABELED = OBJECTS LSTRUC =
STRUC))
ELSEIF
(GREATERP LABELS SZ)
THEN NIL ELSEIF (NULL (CDR (SETQ OBJECTS
(CLASSES
OBJECTS
STRUC))))
THEN
(LABEL1C (CAR OBJECTS)
LABELS STRUC)
ELSE
(LABEL1L OBJECTS LABELS STRUC)))))
)))))))))))))))))
(DE
LABEL1L
(OBJL LABELS STRUC)
(IF (NULL OBJL)
THEN
(IF (ZEROP LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC))
ELSE NIL)
ELSEIF
(ZEROP LABELS)
THEN
(LIST (LABELING LSTRUC = STRUC UNLABELED =
(PROG (R)
(FOR NEW O IN OBJL DO (SETQ R
(COMBINE
O R)))
(RETURN R))))
ELSE
(PROG (SZ SZC)
(SETQ SZ (PLUS (SETQ SZC (SIZE (CAR OBJL)))
(FOR NEW O IN (CDR OBJL)
PLUS
(SIZE O))))
(RETURN (FOR NEW I := ((MAX 0 (DIFFERENCE LABELS
(DIFFERENCE
SZ SZC)))
(MIN LABELS SZC))
FOR NEW L1 IN (LABEL1C (CAR OBJL)
I STRUC)
FOR NEW L2 IN (LABEL1L (CDR OBJL)
(DIFFERENCE LABELS I)
(LSTRUC L1))
XLIST
(LABELING FROM L2 LABELED =
(COMBINE (LABELED L1)
**)
UNLABELED = (COMBINE (UNLABELED
L1)
**)))))))
)))))))))))))))))
(DE COMB1 (OBJ LAB UNL PERMS LABELS)
(IF (ZEROP LABELS)
THEN
(LIST (LABELING LABELED = LAB UNLABELED = UNL LSTRUC = PERMS))
ELSEIF
(EQUAL LABELS (LENGTH OBJ))
THEN
(LIST (LABELING LABELED = (APPEND OBJ LAB)
UNLABELED = UNL LSTRUC = PERMS))
ELSE
(NCONC (COMB1 (CDR OBJ)
(CONS (CAR OBJ)
LAB)
UNL PERMS (SUB1 LABELS))
(COMB1 (CDR OBJ)
LAB
(CONS (CAR OBJ)
UNL)
PERMS LABELS))))
)))))))))))))))))
(DE FIXUPGROUP (STRUC)
(REPLACE (GROUP STRUC)
(FINDNEWGROUP
STRUC
(CLASSIFYNODES
(PROG (X)
(SETQ X (NODES STRUC))
(FOR NEW NL IN (CAR (GROUP STRUC))
DO
(SETQ X (DIFF X NL)))
(RETURN X))
STRUC))))
)))))))))))))))))
(DE FINDNEWGROUP (STRUC NEWORBITS)
(PROG (NEWOBJ)
(SETQ NEWOBJ (FOR NEW ORB IN NEWORBITS XLIST FIRST
(CAR (GROUP STRUC))
(REVERSE ORB)))
(RETURN (CONS NEWOBJ
(FOR NEW P IN (FINDNEWGROUP1 STRUC NEWORBITS)
WHEN
(NOT (EQUAL NEWOBJ (CDR P)))
XLIST
(CDR P))))))
)))))))))))))))))
(DE FINDNEWGROUP1 (STRUC NEWORBITS)
(FOR NEW P IN (GROUP STRUC)
NCONC FIRST NIL (FINDPERMS (CAR NEWORBITS)
NEWORBITS
(CONS NIL P)
(CONS NIL (CAR (GROUP STRUC)))
STRUC)))
)))))))))))))))))
(DE FINDPERMS (NODES CLASSES IMS MAPPED STRUC)
(IF (NULL CLASSES)
THEN
(LIST IMS)
ELSEIF
(NULL NODES)
THEN
(FINDPERMS (CADR CLASSES)
(CDR CLASSES)
(CONS NIL IMS)
(CONS NIL MAPPED)
STRUC)
ELSE
(FOR NEW Y IN (POSSIMS (CAR NODES)
(CAR CLASSES)
IMS MAPPED STRUC)
NCONC FIRST NIL (FINDPERMS (CDR NODES)
CLASSES
(CONS (CONS Y (CAR IMS))
(CDR IMS))
(CONS (CONS (CAR NODES)
(CAR MAPPED))
(CDR MAPPED))
STRUC))))
)))))))))))))))))
(DE POSSIMS (X CLASS IMS MAPPED STRUC)
(FOR NEW Y IN CLASS WHEN (NOT (MEMBER Y (CAR IMS)))
WHEN
(FOR NEW ML IN MAPPED AS NEW IL IN IMS FOR NEW M IN ML AS
NEW I IN IL AND (EQUAL (CONNECTIVITY Y I STRUC)
(CONNECTIVITY X M STRUC)))
XLIST Y))
)))))))))))))))))
(DE CONNECTIVITY (X Y STRUC)
(FOR NEW Z IN (NBRS (FINDCTE X STRUC))
WHEN
(EQUAL Z Y)
PLUS 1))
)))))))))))))))))
(DE GROUPCOUNT (L)
(PROG NIL (SETQ L (GROUPBY (QUOTE CDR)
(CLCREATE L)))
(RETURN (FOR NEW I := ((FOR NEW X IN L MAX (CAR X))
1 -1)
XLIST
(CARLIST (LMASSOC I L NIL))))))
)))))))))))))))))
(DE FOUND? (NODE GROUP)
(FOR NEW NL IN (CAR GROUP)
AS NEW N := (1 9999999)
DO
(IF (MEMBER NODE NL)
THEN
(RETURN (CONS N NL)))))
)))))))))))))))))
(DE
FINDGROUPEDGES
(EDGES STRUC)
(PROG
(G)
(IF (NOT (FOR NEW EDGE IN EDGES AND (AND (FOUND? (NODE1 EDGE)
(GROUP STRUC))
(FOUND? (NODE2 EDGE)
(GROUP STRUC)))))
THEN
(FIXUPGROUP STRUC)
ELSE NIL)
(SETQ G (GROUP STRUC))
(RETURN
(NPL
OKPERMS = (LIST (CAR G))
REMPERMS =
(FOR NEW P IN (CDR G)
XLIST
(CHECKPERM ORIGPERM = P OBJ = EDGES POBJ =
(FOR NEW EDGE IN EDGES LIST
(ORDPAIR (IMAGE (NODE1 EDGE)
(CAR G)
P)
(IMAGE (NODE2 EDGE)
(CAR G)
P)))))))))
)))))))))))))))))
(DE IMAGE (NODE MAPPED IMAGES)
(FOR NEW ML IN MAPPED AS NEW IL IN IMAGES FOR NEW M IN ML AS NEW
I IN IL WHEN (EQUAL NODE M)
DO
(RETURN I)))
)))))))))))))))))
(DE FINDGROUPNODES (OBJECTS STRUC)
(PROG (FOUND)
L1(SETQ FOUND (FOUND? (CAR OBJECTS) (GROUP STRUC)))
(IF (NOT FOUND)
THEN (FIXUPGROUP STRUC)
ELSE (RETURN
(NPL OKPERMS = (LIST (CAR (GROUP STRUC)))
REMPERMS =
(FOR NEW P IN (CDR (GROUP STRUC))
XLIST
(CHECKPERM ORIGPERM = P OBJ = (CDR FOUND)
POBJ = (CAR (NTH P (CAR FOUND))))))))
(GO L1)))
)))))))))))))))))
(DE SIZE (OBJECTS)
(IF (MULTTYPE? OBJECTS)
THEN
(TIMES (MULT OBJECTS)
(SIZE (UNMULTED OBJECTS)))
ELSEIF
(COMBINATION? OBJECTS)
THEN
(PLUS (SIZE (OBJ1 OBJECTS))
(SIZE (OBJ2 OBJECTS)))
ELSEIF
(OR (NODES? OBJECTS)
(EDGES? OBJECTS)
(UNCLASSED? OBJECTS))
THEN
(LENGTH (CDR OBJECTS))
ELSE
(PRINT (CONS OBJECTS (QUOTE (BAD ARG TO SIZE)))
0)))
)))))))))))))))))
(COMMENT MISC COMPUTATION FUNCTIONS)
(DE TD (VL J)
(IF (NOT VL)
THEN 0 ELSE (PLUS (TIMES J (CAR VL))
(TD (CDR VL)
(ADD1 J))))))))))))
)))))))))))))))))
(DE M2/2 (N)
(SUB1 (QUOTIENT N 2)))))))))
)))))))))))))))))
(DE MAXREST (VL J)
(FOR NEW X IN (CDR VL)
AS NEW K := ((ADD1 J)
9999999)
PLUS
(TIMES X (M2/2 K))))))))))))
)))))))))))))))))
(COMMENT FUNCTIONS FOR LOOPS )
(DE LOOPPARTITIONS1 (P VL J)
(IF (NOT VL)
THEN
(LIST NIL)
ELSE
(FOR NEW PJ := ((MAX 0 (DIFFERENCE P (MAXREST VL J)))
(MIN P (TIMES (M2/2 J)
(CAR VL))))
AS NEW RESTL IS (LOOPPARTITIONS1 (DIFFERENCE
P PJ)
(CDR VL)
(ADD1 J))
FOR NEW THISPART IN (FVPART1 PJ (CAR VL)
(M2/2 J))
FOR NEW RESTPART IN RESTL XLIST (CONS THISPART
RESTPART)))))
)))))))))
(DE JLIST (LL N) (IF (NOT LL) THEN NIL
ELSEIF (NOT (CDR LL))
THEN (LIST (CAR (NTH (CAR LL) N)))
ELSE (CONS (CAR (NTH (CAR LL) N))
(JLIST (CDDR LL)
(ADD1 N)))))))))))))))))
(DE LPROWS (LPP VL) (PROG2 (SETQ LPP (CONS NIL LPP))
(FOR NEW S := (4 999999)
AS NEW V IN (CONS (CAR VL)
(FOR NEW V2 IN (CDR VL)
AS NEW PL IN LPP
LIST
(DIFFERENCE V2 (PLUSLIST PL))))
AS LPP IS (IF LPP THEN (CDR LPP) ELSE NIL)
LIST
(CONS V (JLIST LPP (M2/2 S)))))))))))
(DE LOOPPARTITIONS (P VL)
(FOR NEW LPP IN (LOOPPARTITIONS1 P (CDDR VL) 4)
AS NEW ROWS IS (LPROWS LPP VL)
FOR NEW K := (0 (TD (CDR VL) 3))
FOR NEW BP IN (NUMPARTITIONS (CAR VL) (PLUS P K) 1 999999)
AS NEW CLBP IS (CLCREATE BP)
FOR NEW EL IN (CLPARTS CLBP K)
FOR NEW LPL IN (CLPARTITIONSL (CLDIFF CLBP EL) (CDRLIST ROWS))
XLIST (LOOPPARTITION LOOPVL =
(CONS (PLUSLIST (CDAR ROWS))
(MAPCAR @ PLUSLIST(CDR ROWS)))
EDGELABELS = EL
LOOPLABELS = LPL))))))))))))
)))))))))))))))))